perm filename DB.LSP[4,BGB] blob
sn#001281 filedate 1972-11-01 generic text, type T, neo UTF8
(GLOBAL (FUNCTIONS IN-CONTEXT
OBJECT
CFRAME
PUSH-CONTEXT
POP-CONTEXT
SPLICE
FETCHI
FETCHM
REALIZE
UNREALIZE
REAL
UNREAL
ACTUALIZE
UNACTUALIZE
DPUTCF
DGETCF
DREMCF
DPUT
DGET
DREM
DPUT+
DGET+
DREM+
PRESENT
ABSENT
DATUM
MENTIONERS
C-MARKER
!⊗
IF-NEEDED
IF-ADDED
IF-REMOVED
DATA-INIT
FETCH
ADD
REMOVE
INSERT
KILL
FLUSH
NEW-CONTEXT
PATH)
(RESERVED ! !! !? !/, !@ *CONTEXT DATUM *CFRAME GLOBAL *OBJECT CONTEXT *ITEM *METHOD *IGNORE))
(DECLARE (SPECIAL CFRAMES
CNUM
CONTEXT
DATUM
CMARKERS
TYPE
PATTERN
GLOBAL
INCCON
NUMACT
NUMCON
*CNUM
*IF-ADDEDS
*IF-NEEDEDS
*IF-REMOVEDS
*INDEXTHRESHOLD
*ITEMS
NEW)
(*FEXPR !⊗ CDEFUN CERR CSETQ : /, GCCON IF-ADDED IF-NEEDED IF-REMOVED)
(*LEXPR BIND
ABSENT
ADD
CEVAL
CFRAME
CSET
DGET
DGET+
DPUT
DPUT+
DREM
DREM+
FETCH
FETCHI
FETCHM
INSERT
KILL
MATCH
NOTE
OBJECT
POP-CONTEXT
PRESENT
DATA-INIT
PUSH-CONTEXT
REAL
REALIZE
REMOVE
RVALUE
UNREAL
UNREALIZE)
(*EXPR ARGS DATUM CMARKERS PATTERN)
(**ARRAY FRAMES RFRAMES))
(SETQ *INDEXTHRESHOLD 12)
(DEFPROP OBJECT (LAMBDA N (LIST (QUOTE *OBJECT) (COND ((= N 0) NIL) ((= N 1) (ARG 1)) ((TMA))))) EXPR)
(DEFPROP TMA (LAMBDA NIL (CERR TOO MANY ARGUMENTS)) EXPR)
(DEFPROP TFA (LAMBDA NIL (CERR TOO FEW ARGUMENTS)) EXPR)
(DECLARE (UNSPECIAL CMARKERS TYPE))
(DEFPROP MAKE-METHOD
(LAMBDA(TYPE BOD)
(PROG (FIRST OLDM CMARKERS)
(COND ((ATOM (SETQ FIRST (CAR BOD))) (SETQ CMARKERS
(COND
((SETQ OLDM (GET FIRST (QUOTE DATUM)))
(CDR (CMARKERS OLDM)))))
(PUTPROP FIRST
(NCONC (LIST TYPE FIRST (CADR BOD) (CDDR BOD))
CMARKERS)
(QUOTE DATUM))
(RETURN FIRST))
((RETURN (LIST TYPE NIL FIRST (CDR BOD)))))))
EXPR)
(DECLARE (SPECIAL CMARKERS TYPE))
(DEFPROP IF-NEEDED (LAMBDA (A) (MAKE-METHOD (QUOTE IF-NEEDED) A)) FEXPR)
(DEFPROP IF-ADDED (LAMBDA (A) (MAKE-METHOD (QUOTE IF-ADDED) A)) FEXPR)
(DEFPROP IF-REMOVED (LAMBDA (A) (MAKE-METHOD (QUOTE IF-REMOVED) A)) FEXPR)
(DEFPROP DATA-INIT
(LAMBDA K
((LAMBDA(N M)
(PROG NIL
(COND
((BOUNDP (QUOTE NUMACT))
(DO I
0
(/1+ I)
(= I NUMACT)
(DO DATA
(CDDR (FRAMES I))
(CDR DATA)
(NULL DATA)
((LAMBDA (D) (AND (ATOM D) (RPLACD (CMARKERS D) NIL))) (CAR DATA))))))
(SETQ NUMCON N INCCON M)
(ARRAY FRAMES NIL NUMCON)
(ARRAY RFRAMES T NUMCON)
(STORE (FRAMES 0) (SETQ GLOBAL (LIST (QUOTE *CFRAME) (SETQ *CNUM 0))))
(STORE (RFRAMES 0) (CDR GLOBAL))
(SETQ CONTEXT (LIST (QUOTE *CONTEXT) GLOBAL))
(SETQ NUMACT 1)
(PUTPROP (QUOTE ITEM)
(SETQ *ITEMS (LIST (QUOTE *LIST) (QUOTE (PATTERN THING)) 0))
(QUOTE *INDEX))
(PUTPROP (QUOTE IF-NEEDED)
(SETQ *IF-NEEDEDS (LIST (QUOTE *LIST) (QUOTE (PATTERN THING)) 0))
(QUOTE *INDEX))
(PUTPROP (QUOTE IF-ADDED)
(SETQ *IF-ADDEDS (LIST (QUOTE *LIST) (QUOTE (PATTERN THING)) 0))
(QUOTE *INDEX))
(PUTPROP (QUOTE IF-REMOVED)
(SETQ *IF-REMOVEDS (LIST (QUOTE *LIST) (QUOTE (PATTERN THING)) 0))
(QUOTE *INDEX))
(RETURN (SSTATUS INTERRUPT 24 (QUOTE GCCON)))))
(COND ((> K 0) (ARG 1)) (T 144))
(COND ((> K 1) (ARG 2)) (T 12))))
EXPR)
(DECLARE (UNSPECIAL PATTERN))
(DEFPROP FETCH
(LAMBDA N
(PROG (PATTERN CON)
(SETQ PATTERN (ARG 1) CON (GETCONTEXT 1 N))
(RETURN
(CONS (LIST (QUOTE *POSSIBILITIES) PATTERN)
(CONS (QUOTE *IGNORE)
(NCONC (FETCHI1 PATTERN CON) (FETCHM1 PATTERN *IF-NEEDEDS CON)))))))
EXPR)
(DEFPROP FETCHI
(LAMBDA N
(CONS (LIST (QUOTE *POSSIBILITIES) (ARG 1))
(CONS (QUOTE *IGNORE) (FETCHI1 (ARG 1) (GETCONTEXT 1 N)))))
EXPR)
(DEFPROP FETCHM
(LAMBDA N
(PROG NIL
(COND ((> N 3) (TMA)))
(RETURN
((LAMBDA(CON)
(CONS (LIST (QUOTE *POSSIBILITIES) (ARG 1))
(CONS (QUOTE *IGNORE)
(FETCHM1 (ARG 1)
(COND ((< N 2) *IF-NEEDEDS) ((GET (ARG 2) (QUOTE *INDEX))))
CON))))
(COND ((< N 3) (/, CONTEXT)) ((ARG 3)))))))
EXPR)
(DEFPROP FETCHI1
(LAMBDA(PATTERN CON)
(PROG (ALISTS)
(RETURN
(MAPCAN (QUOTE
(LAMBDA(ITEM)
(COND
((SETQ ALISTS (MATCH PATTERN (CAR ITEM)))
(LIST (LIST (QUOTE *ITEM) ITEM (CAR ALISTS)))))))
(SEARCH *ITEMS PATTERN T (CDR CON))))))
EXPR)
(DEFPROP FETCHM1
(LAMBDA(PATTERN INDEX CON)
(MAPCAN (QUOTE
(LAMBDA(METHOD)
((LAMBDA (MRESULT) (COND (MRESULT (LIST (CONS (QUOTE *METHOD) (CONS METHOD MRESULT))))))
(MATCH (PATTERN METHOD) PATTERN))))
(SEARCH INDEX PATTERN NIL (CDR CON))))
EXPR)
(DECLARE (SPECIAL PATTERN))
(DEFPROP REAL (LAMBDA N (AND (REALITY (ARG 1) (GETCONTEXT 1 N)) (ARG 1))) EXPR)
(DEFPROP UNREAL (LAMBDA N (AND (NOT (REALITY (ARG 1) (GETCONTEXT 1 N))) (ARG 1))) EXPR)
(DEFPROP PRESENT
(LAMBDA N
(PROG (CON PAT CANDIDATES ALISTS)
(SETQ PAT (ARG 1) CON (GETCONTEXT 1 N) CANDIDATES (SEARCH *ITEMS PAT T (CDR CON)))
LOOP (COND ((NULL CANDIDATES) (RETURN NIL))
((SETQ ALISTS (MATCH PAT (ITEM (CAR CANDIDATES))))
(MAPC (QUOTE (LAMBDA (PAIR) (CSET (CAR PAIR) (CADR PAIR)))) (CAR ALISTS))
(RETURN (CAR CANDIDATES))))
(SETQ CANDIDATES (CDR CANDIDATES))
(GO LOOP)))
EXPR)
(DEFPROP ABSENT (LAMBDA N (UNREAL (DATUM (ARG 1)) (GETCONTEXT 1 N))) EXPR)
(DECLARE (UNSPECIAL PATTERN))
(DEFPROP SEARCH
(LAMBDA(INDEX PATTERN ITEM CON)
(MAPCAN (QUOTE (LAMBDA (THING) (COND ((REALITY1 (CDR (CMARKERS THING)) CON) (LIST THING)))))
(ISEARCH INDEX PATTERN ITEM)))
EXPR)
(DECLARE (SPECIAL PATTERN))
(DEFPROP REALITY (LAMBDA (DATUM CON) (REALITY1 (CDR (CMARKERS DATUM)) (CDR CON))) EXPR)
(DEFPROP REALITY1
(LAMBDA(CMARKERS CFRAMES)
(PROG (CM CON)
(SETQ CON CFRAMES)
LOOP (COND ((SETQ CM (MFINTERSECT)) (OR (INVISIBLE (CADR CM) CON) (RETURN CM))
(SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
(GO LOOP))
((RETURN NIL)))))
EXPR)
(DEFPROP DATUM
(LAMBDA(SKELETON)
(PROG (CANDIDATES)
(SETQ CANDIDATES (ISEARCH *ITEMS SKELETON T))
LOOP (COND ((NULL CANDIDATES) (RETURN (LIST SKELETON)))
((EQUAL (ITEM (CAR CANDIDATES)) SKELETON) (RETURN (CAR CANDIDATES))))
(SETQ CANDIDATES (CDR CANDIDATES))
(GO LOOP)))
EXPR)
(DEFPROP ADD (LAMBDA N (REALIZE (DATUMIZE (ARG 1)) (GETCONTEXT 1 N))) EXPR)
(CDEFUN ADD (THING ⊗OPTIONAL⊗ (CONTEXT CONTEXT)) (REALIZE (/@ DATUMIZE (/, THING)) CONTEXT))
(DEFPROP REMOVE (LAMBDA N (UNREALIZE (DATUMIZE (ARG 1)) (GETCONTEXT 1 N))) EXPR)
(CDEFUN REMOVE (THING ⊗OPTIONAL⊗ (CONTEXT CONTEXT)) (UNREALIZE (/@ DATUMIZE (/, THING)) CONTEXT))
(DEFPROP INSERT
(LAMBDA N ((LAMBDA (D) (PROG NIL (REVEAL D (GETCONTEXT 1 N)) (RETURN D))) (DATUMIZE (ARG 1))))
EXPR)
(DEFPROP KILL
(LAMBDA N ((LAMBDA (D) (PROG NIL (HIDE D (GETCONTEXT 1 N)) (RETURN D))) (DATUMIZE (ARG 1))))
EXPR)
(DEFPROP ACTUALIZE (LAMBDA N (PROG NIL (REVEAL (ARG 1) (GETCONTEXT 1 N)) (RETURN (ARG 1)))) EXPR)
(DEFPROP UNACTUALIZE (LAMBDA N (PROG NIL (HIDE (ARG 1) (GETCONTEXT 1 N)) (RETURN (ARG 1)))) EXPR)
(DECLARE (UNSPECIAL DATUM) (SPECIAL PAT CON))
(DEFPROP REALIZE
(LAMBDA N
(PROG (DATUM CON PAT)
(SETQ DATUM (ARG 1) CON (GETCONTEXT 1 N))
(COND
((AND (REVEAL DATUM CON) (SETQ PAT (ITEM DATUM)))
(CEVAL (QUOTE (CALLDEMONS (/@ . PAT) (/@ . *IF-ADDEDS) (/@ . CON))))))
(RETURN DATUM)))
EXPR)
(CDEFUN REALIZE
(DATUM ⊗OPTIONAL⊗ (CONTEXT CONTEXT))
⊗AUX⊗
(PAT)
(COND
((/@ AND (REVEAL (/, DATUM) (/, CONTEXT)) (CSETQ PAT (ITEM (/, DATUM))))
(CALLDEMONS PAT (/@ . *IF-ADDEDS) CONTEXT)))
DATUM)
(DEFPROP UNREALIZE
(LAMBDA N
(PROG (DATUM CON PAT)
(SETQ DATUM (ARG 1) CON (GETCONTEXT 1 N))
(COND
((AND (HIDE DATUM CON) (SETQ PAT (ITEM DATUM)))
(CEVAL (QUOTE (CALLDEMONS (/@ . PAT) (/@ . *IF-REMOVEDS) (/@ . CON))))))
(RETURN DATUM)))
EXPR)
(CDEFUN UNREALIZE
(DATUM ⊗OPTIONAL⊗ (CONTEXT CONTEXT))
⊗AUX⊗
(PAT)
(COND
((/@ AND (HIDE (/, DATUM) (/, CONTEXT)) (CSETQ PAT (ITEM (/, DATUM))))
(CALLDEMONS PAT (/@ . *IF-REMOVEDS) CONTEXT)))
DATUM)
(DECLARE (SPECIAL DATUM) (UNSPECIAL PAT CON))
(CDEFUN CALLDEMONS
(PAT INDEX CONTEXT)
⊗AUX⊗
(M)
(/@ CSETQ M (SEARCH (/, INDEX) (/, PAT) NIL (CDR (/, CONTEXT))))
(: TLP)
(COND (M (INVOKE (/@ CAR (/, M)) PAT) (/@ CSETQ M (CDR (/, M))) (GO (QUOTE TLP)))))
(DEFPROP REVEAL
(LAMBDA(DATUM CON)
(PROG (CM STATUS CMARKERS CFRAMES PATTERN CNUM CFRAME NEW TYPE NUM)
(SETQ CMARKERS
(ANALYZE DATUM)
CFRAMES
(SETQ CON (CDR CON))
CM
(ADDCFRAME (SETQ CFRAME (CAR CON)) CMARKERS)
CNUM
(CADR CFRAME)
STATUS
(CADR CM))
(RPLACA (CDR CM) (QUOTE /+))
(COND (STATUS (RETURN NIL))
((AND PATTERN NEW (NULL (CDDR CMARKERS)))
(INDEX DATUM PATTERN (GET TYPE (QUOTE *INDEX)))))
(SETQ CMARKERS (CDDR CMARKERS) CFRAMES (CDR CFRAMES))
LOOP (COND
((SETQ CM (MFINTERSECT))
(COND ((SETQ NUM (INVISIBLE (CADR CM) CON))
(COND
((EQUAL CNUM NUM) (SETQ NEW NIL)
(RPLACA (CDR CM) (OR (DELETE CNUM (CADR CM) 1) (QUOTE /+))))))
((SETQ STATUS T)))
(SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
(GO LOOP))
(NEW (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))))
(RETURN (NOT STATUS))))
EXPR)
(DEFPROP HIDE
(LAMBDA(DATUM CON)
(PROG (PATTERN CFRAMES CMARKERS CNUM STATUS NUM TYPE REM OLD CFRAME CM)
(SETQ CFRAMES (SETQ CON (CDR CON)) CMARKERS (ANALYZE DATUM) CNUM (CADAR CON))
(COND
((SETQ CM (FINDCFRAME (SETQ CFRAME (CAR CFRAMES)) (CDR CMARKERS)))
(SETQ STATUS (CADR CM) OLD T)
(COND ((CDDR CM) (RPLACA (CDR CM) NIL))
((SETQ REM T) (DELQ CM CMARKERS 1)
(AND PATTERN
(NULL (CDR CMARKERS))
(UNINDEX DATUM
PATTERN
(GET TYPE (QUOTE *INDEX))
(EQ TYPE (QUOTE ITEM))))))))
(SETQ CMARKERS (CDR CMARKERS))
LOOP (COND
((SETQ CM (MFINTERSECT))
(COND ((SETQ NUM (INVISIBLE (CADR CM) CON))
(COND (REM (SETQ REM (NOT (EQUAL CNUM NUM)))) ((OR OLD (SETQ OLD (EQUAL CNUM NUM))))))
((SETQ REM NIL STATUS T) (CANCEL CM CNUM)))
(SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
(GO LOOP))
(REM (RPLACD (CDR CFRAME) (DELQ DATUM (CDDR CFRAME) 1)))
((AND STATUS (NOT OLD)) (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))))
(RETURN STATUS)))
EXPR)
(DEFPROP ADDCFRAME
(LAMBDA(CFRAME CMARKERS)
(PROG (N)
(SETQ N (CADR CFRAME))
LOOP (COND ((OR (NULL (CDR CMARKERS)) (LESSP (CAADR CMARKERS) N)) (RPLACD CMARKERS
(CONS
(LIST N NIL)
(CDR CMARKERS)))
(SETQ NEW T))
((EQ N (CAADR CMARKERS)))
(T (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP)))
(RETURN (CADR CMARKERS))))
EXPR)
(DEFPROP FINDCFRAME
(LAMBDA(CFRAME CMARKERS)
(PROG (NF NM)
(SETQ NF (CADR CFRAME))
LOOP (COND ((NULL CMARKERS) (RETURN NIL))
((> NF (SETQ NM (CAAR CMARKERS))) (RETURN NIL))
((> NM NF) (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP))
((RETURN (CAR CMARKERS))))))
EXPR)
(DEFPROP CANCEL (LAMBDA (CM NUM) (RPLACA (CDR CM) (MERGEN NUM (CADR CM)))) EXPR)
(DEFPROP MERGEN
(LAMBDA(N NL)
(COND ((ATOM NL) (LIST N)) ((> N (CAR NL)) (CONS N NL)) ((RPLACD NL (MERGEN N (CDR NL))))))
EXPR)
(DEFPROP DPUTCF
(LAMBDA(DATUM PROPERTY INDICATOR CFRAME)
(PROG (PATTERN TYPE CM TAIL NEW)
(SETQ TAIL (ANALYZE DATUM) CM (ADDCFRAME CFRAME TAIL))
(COND
(NEW (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))
(AND PATTERN (NULL (CDDR TAIL)) (INDEX DATUM PATTERN (GET TYPE (QUOTE *INDEX))))))
(RETURN (DPUT1 CM PROPERTY INDICATOR))))
EXPR)
(DEFPROP DGETCF
(LAMBDA (DATUM INDICATOR CFRAME) (ASSQ INDICATOR (FINDCFRAME CFRAME (CDR (CMARKERS DATUM)))))
EXPR)
(DEFPROP DREMCF
(LAMBDA(DATUM INDICATOR CFRAME)
(PROG (CMARKERS PATTERN TYPE CM PAIR)
(SETQ CMARKERS (ANALYZE DATUM) CM (FINDCFRAME CFRAME (CDR CMARKERS)))
(COND
((AND CM (SETQ PAIR (ASSQ INDICATOR (CDDR CM)))) (DELQ PAIR (CDR CM) 1)
(COND
((NOT (OR (CADR CM) (CDDR CM)))
(DELQ CM CMARKERS 1)
(DELQ DATUM CFRAME 1)))
(COND
((AND PATTERN (NULL (CDR CMARKERS)))
(UNINDEX DATUM
PATTERN
(GET TYPE (QUOTE *INDEX))
(EQ TYPE (QUOTE ITEM)))))
(RETURN PAIR)))))
EXPR)
(DEFPROP DPUT (LAMBDA N (DPUTCF (ARG 1) (ARG 2) (ARG 3) (CADR (GETCONTEXT 3 N)))) EXPR)
(DEFPROP DGET
(LAMBDA N
((LAMBDA (CONTEXT) (DGET1 (CDR (CMARKERS (ARG 1))) (ARG 2) (CDR CONTEXT) NIL)) (GETCONTEXT 2 N)))
EXPR)
(DEFPROP DREM (LAMBDA N (DREM1 (ARG 1) (ARG 2) (CDR (GETCONTEXT 2 N)) NIL)) EXPR)
(DEFPROP DPUT+
(LAMBDA N
((LAMBDA (CM) (COND (CM (DPUT1 CM (ARG 2) (ARG 3))) ((CERR ABSENT DATUM))))
(REALITY (ARG 1) (GETCONTEXT 3 N))))
EXPR)
(DEFPROP DGET+ (LAMBDA N (DGET1 (CDR (CMARKERS (ARG 1))) (ARG 2) (CDR (GETCONTEXT 2 N)) T)) EXPR)
(DEFPROP DREM+ (LAMBDA N (DREM1 (ARG 1) (ARG 2) (CDR (GETCONTEXT 2 N)) T)) EXPR)
(DEFPROP DPUT1
(LAMBDA(CM PROPERTY INDICATOR)
(PROG (PAIR)
(COND ((SETQ PAIR (ASSQ INDICATOR (CDDR CM))) (RPLACA (CDR PAIR) PROPERTY))
((RPLACD (CDR CM) (CONS (SETQ PAIR (LIST INDICATOR PROPERTY)) (CDDR CM)))))
(RETURN PAIR)))
EXPR)
(DEFPROP DGET1
(LAMBDA(CMARKERS INDICATOR CFRAMES SIGN)
(PROG (PAIR CM CON)
(SETQ CON CFRAMES)
LOOP (COND ((NULL (SETQ CM (MFINTERSECT))) (RETURN NIL))
((AND SIGN (INVISIBLE (CADR CM) CON)))
((SETQ PAIR (ASSQ INDICATOR (CDDR CM))) (RETURN PAIR)))
(SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
(GO LOOP)))
EXPR)
(DEFPROP DREM1
(LAMBDA(DATUM INDICATOR CFRAMES SIGN)
(PROG (PAIR CMARKERS TAIL PATTERN TYPE CM CON)
(SETQ CON CFRAMES CMARKERS (CDR (SETQ TAIL (ANALYZE DATUM))))
LOOP (COND ((NULL (SETQ CM (MFINTERSECT))) (RETURN NIL))
((AND SIGN (INVISIBLE (CADR CM) CON)))
((SETQ PAIR (ASSQ INDICATOR (CDDR CM))) (DELQ PAIR (CDR CM))
(COND
((NOT (OR (CADR CM) (CDDR CM)))
(DELQ CM TAIL)
(DELQ DATUM (CAR CFRAMES))))
(COND
((AND PATTERN (NULL (CDR TAIL)))
(UNINDEX DATUM
PATTERN
(GET TYPE (QUOTE *INDEX))
(EQ TYPE (QUOTE ITEM)))))
(RETURN PAIR)))
(SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
(GO LOOP)))
EXPR)
(DEFPROP MENTIONERS
(LAMBDA N
(PROG (CFRAMES CMARKERS MENTIONERS SIGN CM CON)
(COND ((< N 1) (TFA)))
(SETQ CFRAMES
(CDR (COND ((< N 3) (/, CONTEXT)) ((= N 3) (ARG 3)) ((TMA))))
SIGN
(COND ((> N 1) (ARG 2)))
CMARKERS
(CDR (CMARKERS (ARG 1)))
CON
CFRAMES)
LOOP (COND
((SETQ CM (MFINTERSECT)) (OR (AND SIGN (INVISIBLE (CADR CM) CON))
(SETQ MENTIONERS (CONS (CAR CFRAMES) MENTIONERS)))
(SETQ CFRAMES (CDR CFRAMES) CMARKERS (CDR CMARKERS))
(GO LOOP)))
(RETURN (REVERSE MENTIONERS))))
EXPR)
(DECLARE (UNSPECIAL DATUM))
(DEFPROP C-MARKER (LAMBDA (DATUM CFRAME) (FINDCFRAME CFRAME (CDR (CMARKERS DATUM)))) EXPR)
(DECLARE (SPECIAL DATUM))
(DEFPROP MFINTERSECT
(LAMBDA NIL
(PROG (NM NF CM)
ADVANCE
(COND ((AND CMARKERS CFRAMES) (SETQ NF (CADAR CFRAMES) CM (CAR CMARKERS) NM (CAR CM)))
((RETURN NIL)))
TEST (COND ((> NF NM) (OR (SETQ CFRAMES (CDR CFRAMES)) (RETURN NIL))
(SETQ NF (CADAR CFRAMES))
(GO TEST))
((> NM NF) (OR (SETQ CMARKERS (CDR CMARKERS)) (RETURN NIL))
(SETQ CM (CAR CMARKERS) NM (CAR CM))
(GO TEST))
((RETURN CM)))))
EXPR)
(DECLARE (UNSPECIAL CMARKERS))
(DEFPROP INVISIBLE
(LAMBDA(CNUMS CFRAMES)
(AND (NOT (EQ CNUMS (QUOTE /+)))
(OR (NULL CNUMS)
(PROG (NC NF)
(SETQ NC (CAR CNUMS))
LOOP (COND (CFRAMES (SETQ NF (CADAR CFRAMES) CFRAMES (CDR CFRAMES))) ((RETURN NIL)))
TEST (COND ((> NF NC) (GO LOOP))
((> NC NF) (OR (SETQ CNUMS (CDR CNUMS)) (RETURN NIL))
(SETQ NC (CAR CNUMS))
(GO TEST))
((RETURN NC)))))))
EXPR)
(DECLARE (UNSPECIAL CFRAMES))
(DEFPROP GETCONTEXT
(LAMBDA (K N) (COND ((< N K) (TFA)) ((= N K) (/, CONTEXT)) ((= N (SETQ K (/1+ K))) (ARG K)) ((TMA))))
EXPR)
(DECLARE (UNSPECIAL PATTERN))
(DEFPROP ISEARCH (LAMBDA (INDEX PATTERN ITEM) (APPLY (QUOTE APPEND) (CDR (ISEARCH1 INDEX PATTERN ITEM)))) EXPR)
(DEFPROP ISEARCH1
(LAMBDA(INDEX PATTERN ITEM)
(PROG (ASCAR ASCDR)
(COND ((NULL INDEX) (RETURN (LIST 0)))
((EQ (CAR INDEX) (QUOTE *LIST)) (RETURN (CONS (CADDR INDEX) (LIST (CDDDR INDEX)))))
((EQ (CAR INDEX) (QUOTE *INDEX)))
(T (BREAK BAD-STRUCTURE-INDEX--ISEARCH T)))
(RETURN
(COND
((OR (ZEROP (CAR (SETQ ASCAR (ASEARCH (CADDR INDEX) (CAR PATTERN) ITEM))))
(NULL (CDR PATTERN))
(> (CAR (SETQ ASCDR (ASEARCH (CDDDR INDEX) (CDR PATTERN) ITEM))) (CAR ASCAR)))
ASCAR)
(ASCDR)))))
EXPR)
(DEFPROP ASEARCH
(LAMBDA(SUBINDEX ELEMENT ITEM)
(PROG (INDICATOR ASSOCIATION CLLIST VLIST)
(COND ((EQ (SETQ INDICATOR (ATOMIZE ELEMENT)) (QUOTE *VARIABLE)) (RETURN (LIST 377777777777))))
(SETQ CLLIST
(COND ((EQ INDICATOR (QUOTE *STRUCTURE)) (ISEARCH1 (CAR SUBINDEX) ELEMENT ITEM))
((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
(CONS (CADR ASSOCIATION) (LIST (CDDR ASSOCIATION))))
((LIST 0))))
(COND
((AND (NOT ITEM)
(SETQ ASSOCIATION (ASSQ (QUOTE *VARIABLE) (CDR SUBINDEX)))
(SETQ VLIST (CDDR ASSOCIATION)))
(RPLACA CLLIST (/+ (CAR CLLIST) (CADR ASSOCIATION)))
(RPLACD CLLIST (CONS VLIST (CDR CLLIST)))))
(RETURN CLLIST)))
EXPR)
(DEFPROP ASSQ1 (LAMBDA (IND ALIST) (COND ((NUMBERP IND) (ASSOC IND ALIST)) ((ASSQ IND ALIST)))) EXPR)
(DECLARE (SPECIAL THING PFORM INDEX))
(DEFPROP INDEX
(LAMBDA(THING PATTERN INDEX)
(PROG (NUM THINGS PFORM)
(COND ((NULL INDEX) (BREAK BAD-INDEX--INDEX T))
((EQ (CAR INDEX) (QUOTE *LIST))
(COND
((EQUAL (SETQ NUM (/1+ (CADDR INDEX))) *INDEXTHRESHOLD) (RPLACA INDEX (QUOTE *INDEX))
(SETQ THINGS
(CDDDR INDEX)
PFORM
(CADR INDEX))
(RPLACD
(CDR INDEX)
(LIST (LIST NIL) NIL))
(MAPC
(!⊗ LAMBDA
(THING)
(INDEX
THING
(/@ . PFORM)
INDEX))
THINGS))
(T (RPLACD (CDR INDEX) (CONS NUM (CONS THING (CDDDR INDEX)))) (RETURN THING))))
((EQ (CAR INDEX) (QUOTE *INDEX)) (SETQ PFORM (CADR INDEX)))
((BREAK BAD-INDEX--INDEX T)))
(INDEX1 THING (CAR PATTERN) (CADDR INDEX) (QUOTE CAR) PFORM)
(AND (CDR PATTERN) (INDEX1 THING (CDR PATTERN) (CDDDR INDEX) (QUOTE CDR) PFORM))
(RETURN THING)))
EXPR)
(DECLARE (UNSPECIAL PFORM INDEX))
(DEFPROP UNINDEX
(LAMBDA(THING PATTERN INDEX ITEM)
(COND ((NULL INDEX) (BREAK BAD-INDEX--UNINDEX T))
((EQ (CAR INDEX) (QUOTE *LIST)) (RPLACD (CDR INDEX)
(CONS (/1- (CADDR INDEX))
(DELTHING THING (CDDDR INDEX) ITEM)))
THING)
((EQ (CAR INDEX) (QUOTE *INDEX)) (UNINDEX1 THING (CAR PATTERN) (CADDR INDEX) ITEM)
(AND (CDR PATTERN)
(UNINDEX1 THING (CDR PATTERN) (CDDDR INDEX) ITEM))
THING)
((BREAK BAD-INDEX--UNINDEX T))))
EXPR)
(DECLARE (UNSPECIAL THING))
(DEFPROP INDEX1
(LAMBDA(THING ELEMENT SUBINDEX POS PFORM)
(PROG (INDICATOR ASSOCIATION)
(COND
((EQ (SETQ INDICATOR (ATOMIZE ELEMENT)) (QUOTE *STRUCTURE))
(COND ((NULL (CAR SUBINDEX)) (RPLACA SUBINDEX (LIST (QUOTE *LIST) (LIST POS PFORM) 0))))
(INDEX THING ELEMENT (CAR SUBINDEX)))
((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
(RPLACD ASSOCIATION (CONS (/1+ (CADR ASSOCIATION)) (CONS THING (CDDR ASSOCIATION)))))
(T (RPLACD SUBINDEX (CONS (LIST INDICATOR 1 THING) (CDR SUBINDEX)))))))
EXPR)
(DEFPROP UNINDEX1
(LAMBDA(THING ELEMENT SUBINDEX ITEM)
(PROG (ASSOCIATION INDICATOR NUM)
(SETQ INDICATOR (ATOMIZE ELEMENT))
(COND ((EQ INDICATOR (QUOTE *STRUCTURE)) (UNINDEX THING ELEMENT (CAR SUBINDEX) ITEM))
((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
(COND ((ZEROP (SETQ NUM (/1- (CADR ASSOCIATION)))) (DELQ ASSOCIATION SUBINDEX))
(T (RPLACD ASSOCIATION (CONS NUM (DELTHING THING (CDDR ASSOCIATION) ITEM)))))))))
EXPR)
(DECLARE (SPECIAL PATTERN))
(DEFPROP ANALYZE
(LAMBDA(X)
(COND ((NULL X) (CERR MEANINGLESS DATUM /-- ANALYZE))
((ATOM X) (ANALYZE (GET X (QUOTE DATUM))))
((EQ (CAR X) (QUOTE *CLOSURE)) (PROG2 (ANALYZE (CADR X)) (CDDR X) (SETQ DATUM X)))
((EQ (CAR X) (QUOTE *OBJECT)) (SETQ PATTERN NIL TYPE (QUOTE OBJECT)) (CDR X))
((ATOM (SETQ TYPE (CAR X))) (SETQ PATTERN (CADDR X))
(AND (CADR X) (SETQ DATUM (CADR X)))
(CDDDR X))
(T (SETQ PATTERN (CAR X) TYPE (QUOTE ITEM)) X)))
EXPR)
(DECLARE (UNSPECIAL PATTERN))
(DEFPROP CMARKERS
(LAMBDA(DATUM)
(COND ((NULL DATUM) (CERR MEANINGLESS DATUM /-- CMARKERS))
((ATOM DATUM) (CMARKERS (GET DATUM (QUOTE DATUM))))
((EQ (CAR DATUM) (QUOTE *CLOSURE)) (CDDR DATUM))
((EQ (CAR DATUM) (QUOTE *OBJECT)) (CDR DATUM))
((ATOM (CAR DATUM)) (CDDDR DATUM))
(DATUM)))
EXPR)
(DEFPROP PATTERN
(LAMBDA(DATUM)
(COND ((NULL DATUM) (CERR MEANINGLESS DATUM /-- PATTERN))
((ATOM DATUM) (PATTERN (GET DATUM (QUOTE DATUM))))
((EQ (CAR DATUM) (QUOTE *CLOSURE)) (PATTERN (CADR DATUM)))
((ATOM (CAR DATUM)) (CADDR DATUM))
((CAR DATUM))))
EXPR)
(DEFPROP NTH (LAMBDA (EXP N) (COND ((= N 1) (CAR EXP)) ((NTH (CDR EXP) (/1- N))))) EXPR)
(DEFPROP DELTHING
(LAMBDA (THING LIST ITEM) (COND (ITEM (DELITEM (ITEM THING) LIST)) ((DELQ THING LIST 1))))
EXPR)
(DEFPROP DELITEM
(LAMBDA(EXP LIST)
(COND ((NULL LIST) NIL)
((EQUAL EXP (ITEM (CAR LIST))) (CDR LIST))
(T (RPLACD LIST (DELITEM EXP (CDR LIST))))))
EXPR)
(DEFPROP MEMCAR
(LAMBDA(EXP LIST)
(COND ((NULL LIST) NIL) ((EQUAL EXP (ITEM (CAR LIST))) LIST) (T (MEMCAR EXP (CDR LIST)))))
EXPR)
(DEFPROP ITEM
(LAMBDA(DATUM)
(COND ((NULL DATUM) (CERR MEANINGLESS DATUM))
((ATOM DATUM) (ITEM (GET DATUM (QUOTE DATUM))))
(((LAMBDA (PAT) (AND (NOT (ATOM PAT)) PAT)) (CAR DATUM)))))
EXPR)
(DEFPROP DATUMIZE (LAMBDA (THING) (COND ((ATOM THING) THING) ((DATUM THING)))) EXPR)
(DEFPROP ATOMIZE
(LAMBDA(ELEMENT)
(COND ((ATOM ELEMENT) ELEMENT) ((ACTOR (CAR ELEMENT)) (QUOTE *VARIABLE)) (T (QUOTE *STRUCTURE))))
EXPR)
(DEFPROP PUSH-CONTEXT (LAMBDA N (CONS (QUOTE *CONTEXT) (CONS (CFRAME) (CDR (GETCONTEXT 0 N))))) EXPR)
(DEFPROP POP-CONTEXT (LAMBDA N (CONS (QUOTE *CONTEXT) (CDDR (GETCONTEXT 0 N)))) EXPR)
(DECLARE (UNSPECIAL CFRAMES))
(DEFPROP NEW-CONTEXT
(LAMBDA(CFRAMES)
(COND ((ORDERED CFRAMES) (CONS (QUOTE *CONTEXT) CFRAMES)) ((CERR UNORDERED CONTEXT))))
EXPR)
(DECLARE (SPECIAL CFRAMES))
(DEFPROP SPLICE
(LAMBDA(CONTEXT)
(PROG NIL
(RPLACD (CDR CONTEXT)
(CONS (CFRAME (NEWCNUM (CADR (CADDR CONTEXT)) (CADADR CONTEXT))) (CDDR CONTEXT)))
(RETURN CONTEXT)))
EXPR)
(DECLARE (SPECIAL EXPR))
(DEFPROP IN-CONTEXT
(LAMBDA (CONTEXT EXPR) (CEVAL (QUOTE ((CLAMBDA (CONTEXT) (CEVAL (/@ . EXPR))) (/@ . CONTEXT)))))
EXPR)
(DECLARE (UNSPECIAL EXPR))
(CDEFUN IN-CONTEXT (CONTEXT EXPR) (CEVAL EXPR))
(DEFPROP PATH (LAMBDA (C) (CONS (QUOTE *CONTEXT) (MAPCAR (QUOTE CADR) (CDR C)))) EXPR)
(DEFPROP CFRAME
(LAMBDA K
((LAMBDA(NFRAME)
(PROG NIL
(COND ((AND (= NUMACT NUMCON) (= (GCCON) NUMCON)) (CERR TOO MANY CONTEXT-FRAMES)))
(STORE (FRAMES NUMACT) NFRAME)
(STORE (RFRAMES NUMACT) (CDR NFRAME))
(SETQ NUMACT (/1+ NUMACT))
(RETURN NFRAME)))
(LIST (QUOTE *CFRAME) (COND ((ZEROP K) (SETQ *CNUM (/+ INCCON *CNUM))) (T (ARG 1))))))
EXPR)
(DEFPROP ORDERED
(LAMBDA(CLIST)
(OR (NULL CLIST)
(PROG NIL
LOOP (COND
((CDR CLIST) (OR (< (CADADR CLIST) (CADAR CLIST)) (RETURN NIL))
(SETQ CLIST (CDR CLIST))
(GO LOOP)))
(RETURN T))))
EXPR)
(DEFPROP NEWCNUM
(LAMBDA(LOW HIGH)
(PROG (N INC INUSE)
(SETQ N (// (/+ LOW HIGH) 2) INUSE (CNUMSINUSE LOW HIGH) INC 1)
LOOP (COND ((GREATERP HIGH N LOW)
(COND ((MEMBER N INUSE) (SETQ N (/+ N INC) INC (/- 0 (/1+ INC))) (GO LOOP))
((RETURN N))))
((CERR NO NEW CNUM BETWEEN (* LOW) AND (* HIGH))))))
EXPR)
(DEFPROP CNUMSINUSE
(LAMBDA(LOW HIGH)
(PROG (I NUMS J N)
(SETQ I 0 J (/1- NUMACT))
LOOP (COND ((> I J) (RETURN NUMS))
((OR (> LOW (SETQ N (CAR (RFRAMES I)))) (> N HIGH)))
((SETQ NUMS (CONS N NUMS))))
(SETQ I (/1+ I))
(GO LOOP)))
EXPR)
(DEFPROP *GCCON
(LAMBDA NIL
(PROG (M N)
(SETQ N 0 M NUMACT)
NGCLP
(COND ((= M N) (RETURN N)) ((EQ (CDR (FRAMES N)) (RFRAMES N)) (SETQ N (/1+ N)) (GO NGCLP)))
(FLUSH (RFRAMES N))
(STORE (RFRAMES N) 0)
MGCLP
(SETQ M (/1- M))
(COND ((= M N) (RETURN N)) ((EQ (CDR (FRAMES M)) (RFRAMES M)) (GO EXCH)))
(FLUSH (RFRAMES M))
(STORE (RFRAMES M) 0)
(GO MGCLP)
EXCH (STORE (FRAMES N) (FRAMES M))
(STORE (RFRAMES N) (RFRAMES M))
(STORE (RFRAMES M) 0)
(GO NGCLP)))
EXPR)
(DEFPROP GCCON (LAMBDA (L) (SETQ NUMACT (*GCCON))) FEXPR)
(DECLARE (SPECIAL PATTERN))
(DEFPROP FLUSH
(LAMBDA(CFRAME)
(PROG (THING THINGS N PATTERN TYPE CMARKERS)
(SETQ THINGS (CDR CFRAME) N (CAR CFRAME))
LOOP (COND ((NULL THINGS) (RETURN NIL)))
(COND
((AND (REMCFRAME N (SETQ CMARKERS (ANALYZE (SETQ THING (CAR THINGS)))))
PATTERN
(NULL (CDR CMARKERS)))
(UNINDEX THING PATTERN (GET TYPE (QUOTE *INDEX)) (EQ TYPE (QUOTE ITEM)))))
(SETQ THINGS (CDR THINGS))
(GO LOOP)))
EXPR)
(DECLARE (UNSPECIAL PATTERN))
(DEFPROP REMCFRAME
(LAMBDA(N CMARKERS)
(PROG (M CM)
LOOP1
(COND ((NULL (CDR CMARKERS)) (RETURN NIL))
((= N (SETQ M (CAADR CMARKERS))) (RPLACD CMARKERS (CDDR CMARKERS)) (RETURN T))
((> N M) (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP1)))
LOOP2
(SETQ CMARKERS (CDR CMARKERS))
(COND ((NULL CMARKERS) (RETURN NIL))
((ATOM (CADR (SETQ CM (CAR CMARKERS))))
(AND (MEMBER N (CADR CM)) (RPLACA (CDR CM) (OR (DELETE N (CADR CM) 1) (QUOTE /+))))))
(GO LOOP2)))
EXPR)
(DEFPROP !⊗ (LAMBDA (L) (!⊗1 L)) FEXPR)